home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / a_utils / ffccflow / ffccflow.lha / ffccc+flow / ffccc / REDEXP.f < prev    next >
Encoding:
Text File  |  1992-07-31  |  2.5 KB  |  93 lines
  1.       SUBROUTINE REDEXP(IOP,IERR)   
  2. C! Reduce the expression on the stack   
  3.       include 'PARAM.h' 
  4.       include 'CURSTA.h' 
  5.       include 'STACK.h' 
  6.       include 'ALCAZA.h' 
  7.       include 'USUNIT.h' 
  8.       CHARACTER*(MDIMST) CTEMP  
  9.       CHARACTER*(LCOPD) SNEW
  10.       CHARACTER*1 SNUTY 
  11.       include 'OPPREC.h' 
  12. C   
  13. C     WRITE(6,100)  
  14. C  100 FORMAT(//,1X,'Now reduce the expression on the stack')   
  15. C   
  16.       IERR = 0  
  17.     5 CONTINUE  
  18.       IF(NLEVL.LE.1) THEN   
  19.         IERR = 1
  20.         GOTO 900
  21.       ENDIF 
  22. C   
  23.        L1 = MAX(1,LOPD(NLEVL-1))
  24.        L2 = MAX(1,INDEX(COPT(NLEVL-1),' ' )-1)  
  25.        L3 = MAX(1,LOPD(NLEVL))  
  26.        L = L1+L2+L3 
  27. C The exepression to be reduced is SNEW 
  28.        SNEW(:L)=COPD(NLEVL-1)(:L1)//COPT(NLEVL-1)(:L2)//COPD(NLEVL)(:L3)
  29. C   
  30. C check for generic intrinsic function  
  31. C if so, then assign the type of the expression in parentheses  
  32. C to the function   
  33. C   
  34.        IF(CTYP(NLEVL-1).EQ.'$'.AND.COPT(NLEVL-1)(:1).EQ.'(') THEN   
  35.          CTYP(NLEVL-1) = CTYP(NLEVL)
  36.        ENDIF
  37. C   
  38. C check for mixed mode operation
  39. C   
  40.        CALL OPRSLT(CTYP(NLEVL-1),COPT(NLEVL-1),CTYP(NLEVL), 
  41.      &             IERR,SNUTY)  
  42.        IF(IERR.EQ.1) THEN   
  43.          DO 10 ICH=1,NCHST  
  44.            CTEMP(ICH:ICH) = ' ' 
  45.            IF(ICH.EQ.IPOS(NLEVL-1)) CTEMP(ICH:ICH) = '^'
  46.    10    CONTINUE   
  47. C        WRITE(6,110) SSTA(1:NCHST),CTEMP(:NCHST)   
  48.          IFINT=MIN(NCHST,100)   
  49.          WRITE(MZUNIT,110) SSTA(1:IFINT),CTEMP(1:IFINT) 
  50.   110    FORMAT(1X,'!!! MIXED MODE EXPRESSION (BAD OPERATOR IS MARKED)',
  51.      &   /,1X,A,/,1X,A) 
  52.          GOTO 900   
  53.        ENDIF
  54. C   
  55. C treat matching parantheses specially  
  56. C   
  57.        IF(COPT(NLEVL-1).EQ.'('.AND.COPER(IOP).EQ.')') THEN  
  58.          IF(L1.EQ.0) THEN   
  59.            SNUTY = CTYP(NLEVL)  
  60.          ELSE   
  61.            SNUTY = CTYP(NLEVL-1)
  62.          ENDIF  
  63.          SNEW(:L+1) = SNEW(:L)//')' 
  64.          L = L+1
  65.          NLEVL = NLEVL - 1  
  66.          CTYP(NLEVL) = SNUTY
  67.          COPD(NLEVL) = SNEW 
  68.          LOPD(NLEVL) = L
  69.          COPT(NLEVL) = ' '  
  70.          IPOP(NLEVL) = 0
  71.          IPOS(NLEVL) = 0
  72.          GOTO 900   
  73.        ENDIF
  74. C   
  75.        NLEVL = NLEVL-1  
  76.        CTYP(NLEVL) = SNUTY  
  77.        COPD(NLEVL) = SNEW   
  78.        LOPD(NLEVL) = L  
  79.        COPT(NLEVL) = COPER(IOP) 
  80.        IPOP(NLEVL) = ILEFP(IOP) 
  81.        IPOS(NLEVL) = 0  
  82. C   
  83.        IF(IRITP(IOP).GT.IPOP(NLEVL-1)) THEN 
  84.          GOTO 900   
  85.        ENDIF
  86. C   
  87. C continue reduction
  88. C   
  89.       GOTO 5
  90.   900 CONTINUE  
  91.       RETURN
  92.       END   
  93.